home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 26
/
Cream of the Crop 26.iso
/
program
/
p063b9s.zip
/
UNIT
/
AREAMISC.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1997-03-02
|
18KB
|
619 lines
UNIT AreaMisc;
{╔══════════════════════════════════════════════════════════════════════════╗}
{║ Various areamanager routines Last changed: 02.03.96 SA ║}
{║ ║}
{║ (C) Copyright 1989-97 by ║}
{║ Dan Wulff, Jens Sandalgaard, Steen Christensen & S¢ren Ager ║}
{║ ║}
{║ This source may not be given to anybody, without the written permission ║}
{║ from The Portal Team. ║}
{╚══════════════════════════════════════════════════════════════════════════╝}
{$I POPDEFS.INC}
INTERFACE
USES Use32, Dos, PoPTypes, Globals,
OpString;
CONST
TableSize = 2000;
TYPE
FilesRec =RECORD
Time,
size : LongInt;
Name : S12;
END;
FilesTab =ARRAY[1..TableSize] OF FilesRec;
FilesBBSRec=RECORD
Tekst : StringPtr;
Mark : Boolean;
END;
FilesBBSTab=ARRAY[1..TableSize] OF ^FilesBBSRec;
VAR
FdbPath : PathStr;
PROCEDURE SorterFiles(VAR Files: FilesTab; Num: Word);
FUNCTION ReadFileAreas(VAR Area: AreaTabPtr): Integer;
PROCEDURE DisposeFileAreas(VAR Area: AreaTabPtr; Num: Integer);
PROCEDURE AddFilesBBSLine(VAR FilesBBSNum: Word; VAR FilesBBS: FilesBBSTab; CONST s: STRING);
FUNCTION ReadFilesInArea(CONST FPath:PathStr;
Mode : Byte; { Mode: 1=tekst 2=files 4=List file }
VAR Files:FilesTab;
VAR FilesBBS:FilesBBSTab;
VAR FilesBBSNum,NumFiles:Word;
AreaNumber: Word) : Boolean;
PROCEDURE DeAllocateFiles(VAR FilesBBS: FilesBBSTab; VAR FilesBBSNum:Word);
PROCEDURE WriteCurrentFilesBBS(CONST FPath: PathStr; FilesBBSNum: Word;
VAR FilesBBS:FilesBBSTab; Visible: Boolean);
FUNCTION AdoptOrphans(Silent, Show: Boolean; VAR FilesBBS: FilesBBSTab;
VAR Files: FilesTab; VAR NumFiles,FilesBBSNum:Word; CONST Comment: S128) : Boolean;
FUNCTION GetFileInfo(CONST FileName: String; VAR Files: FilesTab; NumFiles:Word) : Integer;
FUNCTION HasFileName(CONST s: STRING): Boolean;
PROCEDURE AddDlC(VAR s: STRING);
PROCEDURE DelDlC(VAR s: STRING);
PROCEDURE IncDlC(VAR s: STRING; Count: Byte);
PROCEDURE ZeroDlC(VAR s: STRING);
FUNCTION GetDlC(s: STRING): LongInt;
FUNCTION WritableFile(CONST FName:PathStr):BOOLEAN;
IMPLEMENTATION
USES OpCrt, OpRoot, OpWindow, OpDos,
StrUtil, OproUtil, NetFile, Display, Opus_173, LogFile, Util, FileUtil,
Input, BBSDef;
FUNCTION WritableFile(CONST FName:PathStr):BOOLEAN;
VAR
dc:DiskClass;
ch,sd:CHAR;
sr:SearchRec;
BEGIN
WritableFile:=FALSE;
ch:=UpCase(FName[1]);
dc:=GetDiskClass(ch,sd);
IF dc IN [CDRomDisk] THEN EXIT;
FINDFIRST(FName,AnyFile,sr);
IF NOT ((DOSERROR=0) AND (sr.Attr AND ReadOnly<>0)) THEN
WritableFile:=TRUE;
FindClose(sr);
END;
FUNCTION GetFileInfo(CONST FileName : String; VAR Files:FilesTab; NumFiles:Word) : Integer;
VAR
top,bund,test : Integer;
s: STRING;
BEGIN
top:=NumFiles;
bund:=1;
s:=StUpCase(Copy(FileName,1,pos(' ',FileName+' ')-1));
IF s<>'' THEN
BEGIN
REPEAT
test:=(top+bund) DIV 2;
IF Files[test].Name>s THEN top:=test-1 ELSE
IF Files[test].Name<s THEN bund:=test+1;
UNTIL (top<bund) OR (s=Files[test].Name);
{ Test:=(Top+Bund) DIV 2;}
IF Files[test].Name<>s THEN test:=0;
END ELSE test:=0;
GetFileInfo:=test;
END;
FUNCTION AdoptOrphans(Silent, Show: Boolean; VAR FilesBBS:FilesBBSTab;
VAR Files: FilesTab; VAR NumFiles, FilesBBSNum: Word; CONST Comment:S128) : Boolean;
TYPE
TableType=ARRAY[1..TableSize] OF Boolean;
VAR
found : ^TableType;
i,num : Integer;
BEGIN
AdoptOrphans:=FALSE;
IF Silent OR Confirm('Adopt ALL orphans in this area >','Y',9) THEN
BEGIN
New(Found);
FillChar(found^,SizeOf(TableType),#0);
FOR i:=1 TO FilesBBSNum DO
BEGIN
num:=GetFileInfo(FilesBBS[i]^.Tekst^,Files,NumFiles);
IF num>0 THEN found^[num]:=True;
END;
num:=0;
FOR i:=1 TO NumFiles DO
IF NOT found^[i] THEN
BEGIN
AddFilesBBSLine(FilesBBSNum,FilesBBS,PAD(Files[i].Name,13)+Comment);
Inc(num);
AdoptOrphans:=TRUE;
END;
Dispose(Found);
IF NOT Silent THEN
UserInformation(8,Long2Str(num)+' file(s) adopted',3,1);
END;
END;
PROCEDURE WriteCurrentFilesBBS(CONST FPath: PathStr;
FilesBBSNum: Word;
VAR FilesBBS: FilesBBSTab;
Visible: Boolean);
VAR
f : TBufTextFile;
i : Word;
io : Integer;
tn : PathStr;
s : STRING;
BEGIN
IF Cfg.BBS.BBSType=btOpus170 THEN Exit;
IF WritableFile(FPath) THEN
BEGIN
tn:=ForceExtension(FPath,'$$$');
IF f.Init(tn, SCreate, Max64k(MaxAvail-1024)) THEN Io:=0 ELSE Io:=-1;
IF Io=0 THEN
BEGIN
FOR i:=1 TO FilesBBSNum DO
BEGIN
s:=TrimTrail(FilesBBS[i]^.Tekst^);
f.WriteLn(s);
Io:=f.GetStatus;
IF Io<>0 THEN Break;
END;
f.Close;
IF Io=0 THEN Io:=f.GetStatus;
f.Done;
IF Io=0 THEN
BEGIN
DeleteFile(ForceExtension(tn,'BAK'));
IF (ExistFile(FPath)) AND (NOT RenameFile(FPath,ForceExtension(tn,'BAK'))) THEN
io:=1
ELSE
IF NOT RenameFile(tn, FPath) THEN io:=1;
END;
END;
IF Io<>0 THEN
BEGIN
IF Visible THEN AskError(8,'Error writing FILES.BBS - keeping old version',3)
ELSE AddLog('!','Error writing '+FPath);
END;
END;
END;
PROCEDURE DeAllocateFiles(VAR FilesBBS:FilesBBSTab; VAR FilesBBSNum:Word);
VAR
i : Integer;
BEGIN
FOR i:=FilesBBSNum DOWNTO 1 DO
BEGIN
DisposeString(FilesBBS[i]^.Tekst);
Dispose(FilesBBS[i]);
END;
FilesBBSNum:=0;
END;
PROCEDURE AddFilesBBSLine(VAR FilesBBSNum: Word; VAR FilesBBS: FilesBBSTab; CONST s: STRING);
BEGIN
Inc(FilesBBSNum);
New(FilesBBS[FilesBBSNum]);
FilesBBS[FilesBBSNum]^.Tekst:=StringToHeap(s);
FilesBBS[FilesBBSNum]^.Mark:=False;
END;
PROCEDURE SorterFiles(VAR Files: FilesTab; Num: Word);
PROCEDURE sorter(l,r: Integer);
VAR
i,j : Integer;
x : S12;
t : FilesRec;
BEGIN
i:=l; j:=r;
x:=Files[(l+r) DIV 2].Name;
REPEAT
WHILE Files[i].Name<x DO
Inc(i);
WHILE x<Files[j].Name DO
Dec(j);
IF i<=j THEN
BEGIN
t:=Files[j];
Files[j]:=Files[i];
Files[i]:=t;
Inc(i); Dec(j);
END;
UNTIL i>j;
IF l<j THEN sorter(l,j);
IF i<r THEN sorter(i,r);
END;
BEGIN
IF Num>1 THEN Sorter(1,Num);
END;
FUNCTION ReadFilesInArea(CONST FPath:PathStr;
Mode : Byte;
VAR Files:FilesTab;
VAR FilesBBS:FilesBBSTab;
VAR FilesBBSNum,NumFiles:Word;
AreaNumber: Word) : Boolean;
LABEL
Slut;
VAR
io : Integer;
sr : SEARCHREC;
Offset : LongInt;
tf : TBufTextFile;
btf : TBufTextFile;
f : TNetFile;
WaitWin : PWait;
s : String;
FilesBBSRec : FilesBBSType;
BEGIN
ReadFilesInArea:=FALSE;
Io:=0;
IF Mode AND 1<>0 THEN
BEGIN
CLRSCR;
New(WaitWin, Init(5, 3, 'Scanning for files'));
END ELSE
WaitWin:=NIL;
IF Mode AND 2<>0 THEN
BEGIN
NumFiles:=0;
FINDFIRST('*.*',archive,sr);
WHILE DOSERROR=0 DO
BEGIN
s:=Copy(sr.Name,1,7);
IF (s<>'FILES.B') AND (s<>'DIR.BBS') AND (s<>'DIR.BAK') AND
(s<>'FILES.D') AND (s<>'FILES.I') AND ((Cfg.BBS.BBSType<>btOpus170) OR (sr.Name<>'LFILE.DAT')) THEN
BEGIN
IF NumFiles<TableSize THEN
BEGIN
Inc(NumFiles);
Move(sr.Time,Files[NumFiles],21);
END ELSE
BEGIN
AddLog('!','Too many files in area');
FindClose(sr);
GOTO Slut;
END;
END;
IF WaitWin<>NIL THEN WaitWin^.Animate;
FindNext(sr);
END;
FindClose(sr);
sorterfiles(files,NumFiles);
END;
IF Mode AND 4<>0 THEN
BEGIN
DeAllocateFiles(FilesBBS,FilesBBSNum);
InOutRes:=0;
IF Mode AND 1<>0 THEN WaitWin^.Text:='Reading FILES.BBS';
IF Cfg.BBS.BBSType=btOpus170 THEN
BEGIN
IF FindAreaByNumber(Cfg.BBS.Path, AreaNumber, Offset) THEN
BEGIN
IF btf.Init(Cfg.BBS.Path+'FILESBBS.DAT', SOpenRead+ShareDenyNone, 4096) THEN
BEGIN
btf.Seek(Offset); Offset:=0;
REPEAT
ReadOneFilesBbsLine(btf, FilesBBSRec);
IF FilesBBSRec.Area_Number=AreaNumber THEN
BEGIN
IF FilesBBSRec.Nxt_Key<>0 THEN Offset:=FilesBBSRec.Nxt_Key;
IF (FilesBBSRec.AFlag AND $80)=0 THEN { Deleted }
BEGIN
IF (FilesBBSRec.AFlag AND 2)<>0 THEN { Comment }
s:=FilesBBSRec.Description
ELSE
IF (FilesBBSRec.AFlag AND $20)=0 THEN {StarName}
s:=Pad(FilesBBSRec.Name,13)+'['+Long2Str(FilesBBSRec.Down_Cntr)+'] '+FilesBBSRec.Description;
END;
IF (MaxAvail<5120) OR (FilesBBSNum>=TableSize) THEN
BEGIN
btf.Done;
AddLog('!','Not enough memory to read all files in area: '+Long2Str(AreaNumber));
GOTO Slut;
END;
AddFilesBBSLine(FilesBBSNum,FilesBBS,s);
END ELSE
IF Offset<>0 THEN
BEGIN
btf.Seek(Offset);
Offset:=0;
FilesBBSRec.Area_Number:=AreaNumber;
END;
IF WaitWin<>NIL THEN WaitWin^.Animate;
UNTIL (btf.EoF) OR (FilesBBSRec.Area_Number<>AreaNumber);
btf.Done;
END;
END;
END ELSE
BEGIN
IF tf.Init(FPath, SOpenRead+ShareDenyW, 2048) THEN
BEGIN
WHILE NOT tf.EoF DO
BEGIN
tf.ReadLn(s);
IF (MaxAvail<5120) OR (FilesBBSNum>=TableSize) THEN
BEGIN
tf.Done;
IF AreaNumber<>0 THEN s:=Long2Str(AreaNumber) ELSE s:=FPath;
AddLog('!','Not enough memory to read FILES.BBS in area: '+s);
GOTO Slut;
END;
AddFilesBBSLine(FilesBBSNum,FilesBBS,s);
IF WaitWin<>NIL THEN WaitWin^.Animate;
END;
tf.Done;
END;
END;
END;
ReadFilesInArea:=(Io<>5);
Slut:
IF Mode AND 1<>0 THEN Dispose(WaitWin, Done);
END;
PROCEDURE DisposeFileAreas(VAR Area:AreaTabPtr; Num:Integer);
VAR
i:Integer;
BEGIN
FOR i:=Num DOWNTO 1 DO
BEGIN
DisposeString(Area^[i]^.FPath);
DisposeString(Area^[i]^.Path);
DisposeString(Area^[i]^.Title);
DisposeString(Area^[i]^.Tag);
Dispose(Area^[i]);
END;
END;
FUNCTION ReadFileAreas(VAR Area:AreaTabPtr): Integer;
TYPE
FlagType = array[1..4] of Byte;
VAR
WaitWin : PWait;
num, io : Integer;
RaAreaNUM : Word;
f, f2 : TNetFile;
fa : PFileStruct;
Buf : POINTER;
NameStr,
FilePathStr,
ListPathStr,
TagStr : STRING;
First, Last,
NameId, FPID,
LPID, TagID : BYTE;
PROCEDURE AddToList(CONST ATitle,Path,FPath:S80; CONST Tag:S10);
VAR
ATag:S10;
AFPath,APath:PathStr;
BEGIN
IF Num<MaxAreas THEN
BEGIN
ATag:=Tag;
APath:=Path;
AFPath:=FPath;
INC(Num);
IF ATag='' THEN STR(Num:3,ATag);
APath:=StUpCase(AddBackSlash(APath));
IF AFPath='' THEN AFPath:=APath+'FILES.BBS';
New(Area^[Num]);
WITH Area^[Num]^ DO
BEGIN
Tag:=StringToHeap(ATag);
Title:=StringToHeap(ATitle);
Path:=StringToHeap(APath);
FPath:=StringToHeap(AFPath);
END;
END;
END;
PROCEDURE ReadGenericFileAreas;
VAR
f : TNetFile;
s:STRING;
Tag:S10;
LP,FP:PathStr;
Title:S80;
BEGIN
IF f.Open(StartPath+PoPGenericAreaFile, 1, False) THEN
BEGIN
WHILE NOT f.EoF DO
BEGIN
f.ReadLine(s);
Tag:='';
Title:=NextWord(' ',s);
Replace(Title,'_',' ',0);
FP:=AddBackSlash(NextWord(' ',s));
LP:=NextWord(' ',s);
AddToList(Title,FP,LP,'');
WaitWin^.Animate;
END;
f.Close;
END;
END;
BEGIN
io:=0;
Num:=0;
New(WaitWin, Init(7, 3, 'Reading file areas........'));
IF ExistFile(StartPath+PoPGenericAreaFile) THEN
ReadGenericFileAreas
ELSE
BEGIN
GetFileStruct(fa,'FILES');
FdbPath := fa^.FDBPath;
NameID:=FindField(fa,bdName);
FPID:=FindField(fa,bdFilePath);
LPID:=FindField(fa,bdListPath);
TagID:=FindField(fa,bdAreaTag);
IF (NameID>0) AND (FPID>0) AND (LPID>0) THEN
BEGIN
IF f.Open(Cfg.BBs.Path+fa^.Name,RecLen(fa),FALSE) THEN
BEGIN
RaAreaNUM := 0;
GetMem(Buf,RecLen(fa));
WHILE NOT f.EOF DO
BEGIN
f.Read(Buf^,nokeep,Wait);
NameStr:=GetFieldText(fa,NameID,Buf);
FilePathStr:=GetFieldText(fa,FPID,Buf);
ListPathStr:=GetFieldText(fa,LPID,Buf);
TagStr:=GetFieldText(fa,TagID,Buf);
{ AN '95 }
INC(RaAreaNUM);
IF FdbPath <> '' THEN Tagstr := Long2str(RaAreanum); { hvis Ra2.x }
IF NameStr<> '' THEN AddToList(NameStr,FilePathStr,ListPathStr,TagStr);
WaitWin^.Animate;
END;
FreeMem(Buf,RecLen(fa));
END;
f.Close;
END;
DisposeFileStruct(fa);
END;
IF (io=0) AND (Cfg.AreaMan.AddInbound) THEN
BEGIN
AddToList('Your VERY OWN Unknown Inbound Directory ;-)',Cfg.Inbound[nsUnknown],'','997');
AddToList('Your VERY OWN Known Inbound Directory ;-)',Cfg.Inbound[nsKnown],'','998');
AddToList('Your VERY OWN Password Inbound Directory ;-)',Cfg.Inbound[nsPassword],'','999');
END;
Dispose(WaitWin, Done);
ReadFileAreas:=Num;
END;
FUNCTION HasFileName(CONST s: STRING): Boolean;
BEGIN
HasFileName:=((s<>'') AND NOT (s[1] IN [#0..#32,';','-','@','%','/']));
END;
{=== Download Counter manipulation ==========================================}
FUNCTION MakeDlCnt(Num: LongInt): S10;
VAR
s : S10;
BEGIN
WITH Cfg.AreaMan DO
BEGIN
s:=DLCntStart+LeftPad(Long2Str(Num),DlCDigits)+DlCntStop;
IF DlCZeroFill THEN s:=Substitute(s, ' ', '0');
END;
MakeDlCnt:=s;
END;
PROCEDURE AddDLC(VAR s: STRING);
VAR
Extra : S10;
Desc : String;
i,j : Byte;
Num : LongInt;
Err : Integer;
BEGIN
IF HasFileName(s) THEN
BEGIN
num:=0;
i:=Pos(' ',s);
IF i=0 THEN
BEGIN
s:=s+' '+MakeDlCnt(Num);
END ELSE
BEGIN
Desc:=Trim(Copy(s,i,255));
Extra:='';
IF Length(Desc)>=2 THEN
BEGIN
IF (Cfg.BBS.BBSType=btMax) AND (Copy(Desc,1,1)='/') THEN
BEGIN
j:=Pos(' ',Desc);
IF j>0 THEN
BEGIN
Extra:=Copy(Desc,1,j);
Delete(Desc,1,j);
Desc:=Trim(Desc);
END ELSE
BEGIN
Extra:=Desc+' ';
Desc:='';
END;
END;
j:=Pos(Cfg.AreaMan.DlCntStop, Desc);
IF (Copy(Desc,1,1)=Cfg.AreaMan.DlCntStart) AND (j>0) THEN
BEGIN
Val(Copy(Desc, 2, j-2), Num, Err);
IF Err<>0 THEN Num:=0;
Delete(Desc, 1, j);
Desc:=Trim(Desc);
END;
END;
s:=Pad(Copy(s,1,i),13)+Extra+MakeDlCnt(Num)+' '+Desc;
END;
END;
END;
PROCEDURE DelDLC(VAR s: STRING);
VAR
Start,
Slut : Byte;
BEGIN
IF HasFileName(s) THEN
BEGIN
AddDLC(s);
Start:=Pos(Cfg.AreaMan.DlCntStart, s);
Slut:=Pos(Cfg.AreaMan.DlCntStop, s);
IF (Slut<Length(s)) AND (s[Start-1]=' ') AND (s[Slut+1]=' ') THEN Inc(Slut);
Delete(s, Start, Slut-Start+1);
END;
END;
PROCEDURE IncDLC(VAR s: STRING; Count: Byte);
VAR
Num : LongInt;
Start,
Slut : Byte;
Err : Integer;
BEGIN
IF HasFileName(s) THEN
BEGIN
AddDLC(s);
Start:=Pos(Cfg.AreaMan.DlCntStart, s);
Slut:=Pos(Cfg.AreaMan.DlCntStop, s);
Val(Trim(Copy(s, Start+1, Slut-Start-1)), Num, Err);
IF Err=0 THEN
s:=Copy(s, 1, Start-1)+MakeDlCnt(Num+Count)+Copy(s, Slut+1, 255);
END;
END;
PROCEDURE ZeroDLC(VAR s: STRING);
BEGIN
IF HasFileName(s) THEN
BEGIN
DelDLC(s);
AddDLC(s);
END;
END;
FUNCTION GetDLC(s: STRING): LongInt;
VAR
Num : LongInt;
Start,
Slut : Byte;
Err : Integer;
BEGIN
Num:=0;
IF HasFileName(s) THEN
BEGIN
AddDLC(s);
Start:=Pos(Cfg.AreaMan.DlCntStart, s);
Slut:=Pos(Cfg.AreaMan.DlCntStop, s);
Val(Trim(Copy(s, Start+1, Slut-Start-1)), Num, Err);
IF Err<>0 THEN Num:=0;
END;
GetDLC:=Num;
END;
END.